home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Struct < prev    next >
Encoding:
Text File  |  1994-12-05  |  5.5 KB  |  184 lines  |  [TEXT/YERK]
  1. \ Modification  History - This file contains data primitives
  2. \  4/11/84  CBD Version 1.00
  3. \  4/26/84  CBD Added  +TO:  for all indexed objects
  4. \  4/26/84  CBD Optimized  fetches and stores with code
  5. \  4/27/84  CBD Changed Ordered-Col to work right
  6. \  4/28/84  CBD Added  INT: method for Ints
  7. \  5/23/84  NDI OBJECT read & write methods
  8. \  5/25/84  NDI File handling moved from File.scr
  9. \  6/10/84  CBD Moved EVENT class into STRUCT
  10. \  6/10/84  CBD Added CLEAR: method for arrays
  11. \  6/11/84  NDI Swapped stack input for read & write
  12. \  8/08/84  CBD Added default ClassInit: method to Object
  13. \ 10/10/84  CBD Removed Object to Object.scr
  14. \ 10/11/84  CBD Removed File to file.scr
  15. \ 10/12/84  CBD Removed Set:, Dispatch: is now Exec:
  16. \ 10/12/84  CBD Methods no longer pull names from input stream
  17. \ 10/12/84  CBD Ordered-collection is simpler and faster
  18. \ 10/30/84  CBD Moved Var to Object.scr
  19. \ 11/20/84  CBD Ordered-Col is subclass of X-Array; more handle methods
  20. \ 11/22/84  cbd Added wordCol
  21. \ 12/08/84  cbd ß1.0 version
  22. \ 11/04/85  cdn Added $= ; Fixed new: method in Array
  23. \  9/26/86  cdn Added check for 0 handle in release: handleobj
  24. \  3/08/88    rfl    lock: handle does not keep the pointer; added unlock etc
  25. \  7/02/90    rfl    added moveHi to lock (as in IMAC)
  26. \  9/27/90    rfl    added hgetstate and hsetstate to handle
  27. \ 12/13/90    rfl    made locked?: clean as in MOPS
  28. \  2/22/91    rfl    added negate: to int and var
  29. \  4/30/93    rfl added valid: to handle; setsize!: preserves handle state
  30. \ 10/29/94    rfl    added compactMem
  31. Decimal
  32. ' null cfa value nullCfa
  33.  
  34. \ handy handle primitives
  35. create unlock        ( h --)        $ 205f w, $ a02a w, next,
  36. create hgetstate    ( -- st)    popa0 $ a069 w, pushd0 next,
  37. create hsetstate    ( st h --)    popa0 popd0 $ a06a w, next,
  38. create reserveMem    ( --)        $ 201f w, $ a040 w, next,
  39. create moveHi        ( h --)        popA0 $ a064 w, next,
  40. create compactMem    ( n -- n)    popD0 $ a04c w, pushD0 next,
  41.  
  42. \ =========== Variables =============
  43. :CLASS Int  <Super Object
  44.  
  45.     2 BYTES DATA
  46.  
  47.     :M  CLEAR:    0 MW!            ;M
  48.     :M  GET:    MW@                ;M    \ Fetch
  49.     :M  INT:    MW@  makeInt    ;M    \ Return as toolbox INT
  50.     :M  UGET:    MW@ $ ffff and    ;M    \ get as unsigned
  51.     :M  PUT:    MW!                ;M    \ Store
  52.     :M  +:        COPYM   W+!        ;M    \ add value to a word
  53.     :M  PRINT:    MW@ .            ;M
  54.     :M  =:        MW@ swap W!        ;M    \ addr =:  int
  55.     :M  NEGATE: MW@ negate MW!  ;M
  56.  
  57. ;CLASS
  58.  
  59. \ Define the basic 4-byte variable class
  60. :CLASS Var  <Super Object
  61.  
  62.     4 BYTES Data
  63.  
  64.     :M  CLEAR:    0 M! ;M
  65.     :M  GET:    M@   ;M
  66.  
  67.     \ ( -- ^obj ) get contents as an object  pointer
  68.     :M  OBJ:    M@ dup 0= classErr" 157  ;M    \ invalid obj addr
  69.     :M  PUT:    M!           ;M
  70.     :M  +:        COPYM   +!   ;M
  71.     :M  PRINT:    M@ .  ;M
  72.     :M  DISPOSE:  copym dispose  ;M    \ dispose of heap ptr
  73.     :M  EXEC:    M@ dup 0= classErr" 131 execute ;M
  74.     :M  =:        M@ swap !  ;M    \ r to l assignment to address
  75.     :M  NEGATE: M@ negate M! ;M
  76.  
  77. ;CLASS
  78.  
  79. \ Handle class can store handles to relocatable heap blocks.
  80. :CLASS Handle  <Super Var
  81.  
  82.     :M  VALID: ( -- b) m@ ?ishandle ;M
  83.  
  84.     :M  LOCKED?: ( -- b)   m@ hGetState $ 80 and ;M
  85.     :M  GETSTATE: ( -- st) m@ hGetState ;M
  86.     :M  SETSTATE: ( st --) m@ hSetState ;M
  87.  
  88.     :M  LOCK:  m@ moveHi m@  lock  drop  ;M    \ lock the heap and don't keep rel. ptr
  89.     :M  UNLOCK: m@ unlock ;M
  90.  
  91.     :M  PTR:  m@  >ptr  ;M    \ return relative pointer from handle
  92.     :M  RELEASE:  m@ -dup IF killHandle 0 m! THEN   ;M    \ dispose of heap
  93.  
  94.     \ ( size -- )  set new size for handle
  95.     :M  SETSIZE:  m@ swap setHSize ?error 166  ;M    \ SetHandleSize failed
  96.  
  97.     \ ( size -- )  set new size for handle - If handle is locked, still works
  98.     :M  SETSIZE!:  m@ hGetState  m@ rot m@ unlock setHSize swap m@ hSetState
  99.         ?error 166  ;M    \ SetHandleSize failed
  100.  
  101.     \ ( -- size )  return current size
  102.     :M  SIZE:  get: self  getHSize   ;M
  103.  
  104.     \ ( len -- )  obtain handle to Len bytes of heap and store it in data
  105.     :M  NEW:  newHandle  m!  ;M
  106.  
  107.     :M  MOVEHI: m@ moveHi ;M
  108.     \ ( -- tf)
  109.  
  110. ;CLASS
  111.  
  112. \ ============= Arrays =============
  113.  
  114. \ Basic 4-byte cell array
  115. :CLASS Array  <Super Object  4 <Indexed
  116. \ uses basic methods defined in Object
  117.  
  118.     \ ( ind -- )  return relative pointer from handle
  119.     :M  PTR:  AT4  >ptr  ;M
  120.  
  121.     \ ( ind -- )  dispose of non-relocatable heap
  122.     :M  DISPOSE: ^elem dispose   ;M
  123.  
  124.     \ ( ind -- )   dispose of relocatable heap
  125.     :M  RELEASE:  dup at: self  killHandle
  126.         0 swap to: self    ;M
  127.  
  128.     \ ( ind len -- )  obtain ptr to Len bytes of heap and store it in data
  129.     :M  NEW:  newPtr swap TO4  ;M
  130.  
  131. ;CLASS
  132.  
  133. \ x-Array can execute its elements
  134. :CLASS X-Array  <Super Array
  135.  
  136.     \ ( ind -- )  execute the cfa at Ind
  137.     :M  EXEC:  AT: SELF dup 0=
  138.         classErr" 131 EXECUTE   ;M
  139.  
  140.     :M  CLASSINIT:  limit  0
  141.         DO  nullCfa i To: self  LOOP  ;M
  142.  
  143. ;CLASS
  144.  
  145. \ =========== Lists ===========
  146. \ Ordered-Collection is an ordered list with current size
  147. :CLASS Ordered-Col  <Super X-Array  4 <Indexed
  148.  
  149.     Int        Size    \ # elements in list
  150.  
  151.     \ ( -- curSize )  Return #elements currently in list
  152.     :M  SIZE:  Get: Size  ;M
  153.  
  154.     \ ( -- )  set to null list
  155.     :M  CLEAR:  Clear: Size   Clear: Super  ;M
  156.  
  157.     \ ( val -- )  Add value to end of list
  158.     :M  ADD:  Get: Size  limit  >=
  159.         classErr" 137  Get: size  To: Self
  160.         1 +: Size   ;M
  161.  
  162.     \ ( -- ^file )  return contents of end of list
  163.     :M  LAST:  get: size  dup 0= classerr" 136
  164.         1- at: self    ;M
  165.  
  166.     \ ( ind -- )  remove the element at index
  167.     :M  REMOVE: { ind -- }  ind   Get: size >=
  168.         classErr" 136 Get: size 1- ind
  169.         DO  I 1+ at: self  I to: self LOOP  -1 +: size  ;M
  170.  
  171.     \ ( val -- ind t OR f)  Find a value in an OC
  172.     :M  INDEXOF:  0 swap Get: Size  0
  173.         DO I  at4
  174.             over = IF 2drop  I 1 1 leave THEN
  175.         LOOP  drop  ;M
  176.  
  177. ;CLASS
  178.  
  179. : $= { addr1 len1 addr2 len2 -- }
  180.     word0 addr1 +base addr2 +base len1 len2 pack w 10
  181.     $ a9ed Trap i->l ;
  182.  
  183. <" BasicStr
  184.